home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
thomas
/
thomas.lha
/
Thomas
/
Thomas-1.1
/
src
/
runtime-collections-string.scm
< prev
next >
Wrap
Text File
|
1992-08-30
|
12KB
|
352 lines
;* Copyright 1992 Digital Equipment Corporation
;* All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions. Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software. Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software. Correspondence should be provided to Digital at:
;*
;* Director, Cambridge Research Lab
;* Digital Equipment Corp
;* One Kendall Square, Bldg 700
;* Cambridge MA 02139
;*
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.
;*
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.
; $Id: runtime-collections-string.scm,v 1.17 1992/08/31 05:26:50 birkholz Exp $
;;;; Specializations for string and byte-string types.
(add-method dylan:as
(dylan::function->method
(make-param-list `((CLASS ,(dylan::make-singleton <byte-string>))
(COLLECTION ,<collection>)) #F #F #F)
(lambda (class collection)
class
(if (dylan-call dylan:instance? collection <byte-string>)
collection
(let* ((size (dylan-call dylan:size collection))
(new-string (make-string size)))
(do ((state (dylan-call dylan:initial-state collection)
(dylan-call dylan:next-state collection state))
(index 0 (+ index 1)))
((not state) new-string)
(let ((cur-element
(dylan-call dylan:current-element collection state)))
(string-set! new-string index
(dylan-call
dylan:as <character> cur-element)))))))))
(add-method dylan:as
(dylan::function->method
(make-param-list `((CLASS ,(dylan::make-singleton <string>))
(COLLECTION ,<collection>)) #F #F #F)
(lambda (class collection)
class
(if (dylan-call dylan:instance? collection <string>)
collection
(dylan-call dylan:as <byte-string> collection)))))
;;;
;;; BYTE-STRING MAKE yields a Scheme string
;;;
;;; size keyword overrides inherited dimensions keyword (which is not used)
;;;
(add-method
dylan:make
(dylan::dylan-callable->method
(make-param-list `((STRING ,(dylan::make-singleton <byte-string>)))
#F #F '(size: fill:))
(lambda (multiple-values next-method class . rest)
multiple-values class ; Not used
(dylan::keyword-validate next-method rest '(size: fill:))
(let* ((size (dylan::find-keyword rest 'size: (lambda () 0)))
(have-fill? #T)
(fill (dylan::find-keyword rest 'fill:
(lambda () (set! have-fill? #F) #F))))
(if (or (not (integer? size)) (negative? size))
(dylan-call dylan:error
"(make (singleton <string>)) -- size: invalid" size))
(if (and have-fill? (not (char? fill)))
(dylan-call dylan:error
"(make (singleton <string>)) -- fill: not a character"
fill))
(if have-fill?
(make-string size fill)
(make-string size))))))
;;;
;;; STRING SPECIALIZED MAKE
;;; And we'll make <string> turn into <byte-string>
;;;
(add-method dylan:make
(dylan::function->method
(make-param-list `((STRING ,(dylan::make-singleton <string>)))
#F #F #T)
(lambda (class . rest)
class ; Ignored
(dylan-apply dylan:make <byte-string> rest))))
;;;
;;; UNICODE-STRING SPECIALIZED MAKE
;;; <unicode-string> not supported
;;;
(add-method dylan:make
(dylan::function->method
(make-param-list `((UNICODE
,(dylan::make-singleton <unicode-string>)))
#F #F #T)
(lambda (class . rest)
class ; Ignored
rest ; Ignored
(dylan-call dylan:error
"(make (singleton <unicode-string>)) -- not supported"))))
;;;
;;; FUNCTIONS FOR COLLECTIONS (page 99)
;;;
(add-method dylan:size
(one-arg 'STRING <byte-string>
(lambda (string) (string-length string))))
(add-method dylan:class-for-copy
(dylan::function->method one-string (lambda (x) x <byte-string>)))
;;;;
;;;; Functions for Sequences (page 104)
;;;;
(add-method dylan:add
(dylan::function->method one-byte-string-and-an-object
(lambda (the-string new-element)
(if (char? new-element)
(string-append (string new-element) the-string)
(dylan-call dylan:error "(add <byte-string> <object>) -- cannot add a non-character to string" the-string new-element)))))
(add-method dylan:concatenate
(dylan::function->method
(make-param-list `((BYTE-STRING ,<byte-string>)) #F 'REST #F)
(lambda (string-1 . rest)
(let loop ((result string-1)
(rest-strings
(map (lambda (seq)
(dylan-call dylan:as <byte-string> seq))
rest)))
(if (null? rest-strings)
result
(loop (string-append result (car rest-strings))
(cdr rest-strings)))))))
(add-method dylan:concatenate
(dylan::function->method
(make-param-list `((STRING ,<string>)) #F 'REST #F)
(lambda (string-1 . rest)
(dylan-call dylan:apply dylan:concatenate string-1 rest))))
(add-method dylan:reverse
(dylan::function->method one-byte-string
(lambda (string-1)
(let ((result (make-string (string-length string-1))))
(do ((from (- (string-length string-1) 1) (- from 1))
(to 0 (+ to 1)))
((< from 0) result)
(string-set! result to (string-ref string-1 from))
result)))))
(add-method dylan:reverse!
(dylan::function->method one-byte-string
(lambda (string-1)
(do ((from (- (string-length string-1) 1) (- from 1))
(to 0 (+ to 1)))
((<= from to) string-1)
(let ((to-char (string-ref string-1 to)))
(string-set! string-1 to (string-ref string-1 from))
(string-set! string-1 from to-char))))))
(add-method dylan:first
(dylan::function->method one-string
(lambda (string)
(if (= (string-length string) 0)
(dylan-call dylan:error "(first <string>) -- string is empty" string)
(string-ref string 0)))))
(add-method dylan:first
(dylan::function->method one-byte-string
(lambda (string)
(if (= (string-length string) 0)
(dylan-call dylan:error
"(first <byte-string>) -- byte-string is empty" string)
(string-ref string 0)))))
(add-method dylan:second
(dylan::function->method one-string
(lambda (string)
(if (< (string-length string) 2)
(dylan-call dylan:error
"(second <string>) -- string doesn't have 2 elements"
string)
(string-ref string 1)))))
(add-method dylan:second
(dylan::function->method one-byte-string
(lambda (string)
(if (< (string-length string) 2)
(dylan-call dylan:error
"(second <string>) -- string doesn't have 2 elements"
string)
(string-ref string 1)))))
(add-method dylan:third
(dylan::function->method one-string
(lambda (string)
(if (< (string-length string) 3 )
(dylan-call dylan:error
"(third <string>) -- string doesn't have 3 elements"
string)
(string-ref string 2)))))
(add-method dylan:third
(dylan::function->method one-byte-string
(lambda (string)
(if (< (string-length string) 3 )
(dylan-call dylan:error
"(third <byte-string>) -- string doesn't have 3 elements"
string)
(string-ref string 2)))))
(add-method dylan:last
(dylan::function->method one-string
(lambda (string)
(let ((sl (string-length string)))
(if (zero? sl)
(dylan-call dylan:error "(last <string>) -- string is empty" string)
(string-ref string (- sl 1)))))))
(add-method dylan:last
(dylan::function->method one-byte-string
(lambda (string)
(let ((sl (string-length string)))
(if (zero? sl)
(dylan-call dylan:error
"(last <byte-string>) -- byte-string is empty" string)
(string-ref string (- sl 1)))))))
;;;; Operations on Strings (page 119)
(add-method dylan:binary< (dylan::function->method two-strings string<?))
;; Generic function dylan:as-lowercase defined in runtime-functions.scm.
(add-method
dylan:as-lowercase
(dylan::function->method
(make-param-list `((BYTE-STRING ,<byte-string>)) #F #F #F)
(lambda (string)
(list->string (map (lambda (char) (char-downcase char))
(string->list string))))))
(define dylan:as-lowercase!
(dylan::generic-fn 'as-lowercase! one-string #F))
(add-method
dylan:as-lowercase!
(dylan::function->method
(make-param-list `((BYTE-STRING ,<byte-string>)) #F #F #F)
(lambda (string)
(do ((index 0 (+ index 1)))
((>= index (string-length string)) string)
(string-set! string index (char-downcase (string-ref string index)))))))
;; Generic function dylan:as-uppercase defined in runtime-functions.scm.
(add-method
dylan:as-uppercase
(dylan::function->method
(make-param-list `((BYTE-STRING ,<byte-string>)) #F #F #F)
(lambda (string)
(list->string (map (lambda (char) (char-upcase char))
(string->list string))))))
(define dylan:as-uppercase!
(dylan::generic-fn 'as-uppercase! one-string #F))
(add-method
dylan:as-uppercase!
(dylan::function->method
(make-param-list `((BYTE-STRING ,<byte-string>)) #F #F #F)
(lambda (string)
(do ((index 0 (+ index 1)))
((>= index (string-length string)) string)
(string-set! string index (char-upcase (string-ref string index)))))))
(add-method dylan:previous-state ; Not specified in the manual
(dylan::function->method
(make-param-list `((STRING ,<string>) (STATE ,<number>)) #F #F #F)
(lambda (string offset)
string ; unused
(if (= offset 0) #F (- offset 1)))))
;;;
;;; Collection Keys
;;;
(add-method
dylan:element
(dylan::dylan-callable->method
(make-param-list `((BYTE-STRING ,<byte-string>) (INDEX ,<integer>))
#F #F '(default:))
(lambda (multiple-values next-method string-value index . rest)
multiple-values
(dylan::keyword-validate next-method rest '(default:))
(let ((size (string-length string-value)))
(if (and (>= index 0) (< index size))
(string-ref string-value index)
(dylan::find-keyword
rest '(default:)
(lambda ()
(dylan-call dylan:error "(element <byte-string> <integer>) -- invalid index with no default value" string-value index))))))))
;;;
;;; Mutable Collections
;;;
(add-method dylan:setter/current-element/
(dylan::function->method
(make-param-list
`((BYTE-STRING ,<byte-string>) (STATE ,<object>) (new-value ,<object>))
#F #F #F)
(lambda (the-string state new-value)
(string-set! the-string (vector-ref state 0) new-value)
new-value)))
(add-method dylan:setter/element/
(dylan::function->method
(make-param-list
`((BYTE-STRING ,<byte-string>) (INDEX ,<object>) (NEW-VALUE ,<object>))
#F #F #F)
(lambda (string index new-value)
(string-set! string index new-value)
new-value)))